home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / copascal.arc / BLOCKC.MOD < prev    next >
Encoding:
Text File  |  1986-01-29  |  10.7 KB  |  327 lines
  1.       procedure IFSTATEMENT;
  2.       var X: ITEM;
  3.           LC1,LC2: integer;
  4.       begin
  5.         INSYMBOL;
  6.         EXPRESSION(FSYS+[thenSY,DOSY], X);
  7.         if NOT (X.TYP in [BOOLS,NOTYP]) then ERROR(17);
  8.         LC1 := LC;
  9.         EMIT(11);  { JMPC }
  10.         if SY = thenSY then INSYMBOL else begin
  11.           ERROR(52);
  12.           if SY = DOSY then INSYMBOL;
  13.         end;
  14.         STATEMENT(FSYS+[elseSY]);
  15.         if SY = elseSY then begin
  16.           INSYMBOL;
  17.           LC2 := LC;
  18.           EMIT(10);
  19.           CODE[LC1].Y := LC;
  20.           STATEMENT(FSYS);
  21.           CODE[LC2].Y := LC;
  22.         end else CODE[LC1].Y := LC;
  23.       end;  { IFSTATEMENT }
  24.  
  25.       procedure CASESTATEMENT;
  26.       var X: ITEM;
  27.           I,J,K,LC1: integer;
  28.           CASETAB: array [1..CSMAX] of record
  29.                      VAL,
  30.                      LC  : INDEX
  31.                    end;
  32.           EXITTAB: array [1..CSMAX] of integer;
  33.  
  34.         procedure CASELABEL;
  35.         var LAB: CONREC; K: integer;
  36.         begin
  37.           CONSTANT(FSYS+[COMMA,COLON], LAB);
  38.           if LAB.TP <> X.TYP then ERROR(47) else
  39.           if I = CSMAX then FATAL(6) else begin
  40.             I := I+1;
  41.             K := 0;
  42.             CASETAB[I].VAL := LAB.I;
  43.             CASETAB[I].LC := LC;
  44.             repeat
  45.               K := K+1
  46.             until CASETAB[K].VAL = LAB.I;
  47.             if K < I then ERROR(1);   (*MULTIPLE DEFINITION*)
  48.           end;
  49.         end; (*CASELABEL*)
  50.  
  51.         procedure ONECASE;
  52.         begin if SY in CONSTBEGSYS then
  53.           begin CASELABEL;
  54.             while SY = COMMA do begin
  55.               INSYMBOL;
  56.               CASELABEL
  57.             end;
  58.             if SY = COLON then INSYMBOL else ERROR(5);
  59.             STATEMENT([SEMICOLON,ENDSY]+FSYS);
  60.             J := J + 1;
  61.             EXITTAB[J] := LC; EMIT(10)
  62.           end
  63.         end (*ONECASE*) ;
  64.  
  65.       begin
  66.         INSYMBOL;
  67.         I := 0;
  68.         J := 0;
  69.         EXPRESSION(FSYS+[OFSY,COMMA,COLON], X);
  70.         if NOT (X.TYP in [INTS,BOOLS,CHARS,NOTYP]) then ERROR(23);
  71.         LC1 := LC; EMIT(12);  (*JMPX*)
  72.         if SY = OFSY then INSYMBOL else ERROR(8);
  73.         ONECASE;
  74.         while SY = SEMICOLON do begin
  75.           INSYMBOL;
  76.           ONECASE
  77.         end;
  78.         CODE[LC1].Y := LC;
  79.         for K := 1 TO I do begin
  80.           EMIT1(13,CASETAB[K].VAL);
  81.           EMIT1(13,CASETAB[K].LC)
  82.         end;
  83.         EMIT1(10,0);
  84.         for K := 1 TO J do CODE[EXITTAB[K]].Y := LC;
  85.         if SY = ENDSY then INSYMBOL else ERROR(57)
  86.       end (*CASESTATEMENT*) ;
  87.  
  88.       procedure repeatSTATEMENT;
  89.       var X: ITEM; LC1: integer;
  90.       begin
  91.         LC1 := LC;
  92.         INSYMBOL; STATEMENT([SEMICOLON,UNTILSY]+FSYS);
  93.         while SY in [SEMICOLON]+STATBEGSYS do begin
  94.           if SY = SEMICOLON then INSYMBOL else ERROR(14);
  95.           STATEMENT([SEMICOLON,UNTILSY]+FSYS)
  96.         end;
  97.         if SY = UNTILSY then begin
  98.           INSYMBOL; EXPRESSION(FSYS, X);
  99.           if NOT (X.TYP in [BOOLS,NOTYP]) then ERROR(17);
  100.           EMIT1(11,LC1)
  101.         end else ERROR(53)
  102.       end (*repeatSTATEMENT*) ;
  103.  
  104.       procedure whileSTATEMENT;
  105.       var X: ITEM; LC1,LC2: integer;
  106.       begin
  107.         INSYMBOL;
  108.         LC1 := LC;
  109.         EXPRESSION(FSYS+[DOSY], X);
  110.         if NOT (X.TYP in [BOOLS,NOTYP]) then ERROR(17);
  111.         LC2 := LC; EMIT(11);
  112.         if SY = DOSY then INSYMBOL else ERROR(54);
  113.         STATEMENT(FSYS);
  114.         EMIT1(10,LC1);
  115.         CODE[LC2].Y := LC
  116.       end; (* WHILESTATEMENT *)
  117.  
  118.       procedure FORSTATEMENT;
  119.       var CVT : TYPES;
  120.           X   : ITEM;
  121.           I,F,LC1,LC2 : integer;
  122.       begin
  123.         INSYMBOL;
  124.         if SY = IDENT then begin
  125.           I := LOC(ID);
  126.           INSYMBOL;
  127.           if I = 0 then CVT := INTS
  128.             else if TAB[I].OBJ = VARIABLE then begin
  129.               CVT := TAB[I].TYP;
  130.               if NOT TAB[I].NORMAL then ERROR(37)
  131.                 else EMIT2(0, TAB[I].LEV, TAB[I].ADR);
  132.               if NOT (CVT in [NOTYP,INTS,BOOLS,CHARS]) then ERROR(18)
  133.             end else begin
  134.               ERROR(37);
  135.               CVT := INTS
  136.             end
  137.           end else SKIP([BECOMES,TOSY,DOWNTOSY,DOSY]+FSYS, 2);
  138.           if SY = BECOMES then begin
  139.             INSYMBOL;
  140.             EXPRESSION([TOSY,DOWNTOSY,DOSY]+FSYS, X);
  141.             if X.TYP <> CVT then ERROR(19);
  142.           end else SKIP([TOSY,DOWNTOSY,DOSY]+FSYS, 51);
  143.         F := 14;
  144.         if SY in [TOSY, DOWNTOSY] then begin
  145.           if SY = DOWNTOSY then F := 16;
  146.           INSYMBOL;
  147.           EXPRESSION([DOSY]+FSYS, X);
  148.           if X.TYP <> CVT then ERROR(19)
  149.         end else SKIP([DOSY]+FSYS, 55);
  150.         LC1 := LC; EMIT(F);
  151.         if SY = DOSY then INSYMBOL else ERROR(54);
  152.         LC2 := LC;
  153.         STATEMENT(FSYS);
  154.         EMIT1(F+1,LC2);
  155.         CODE[LC1].Y := LC
  156.       end; (* FORSTATEMENT *)
  157.  
  158.       procedure STANDPROC( N : integer );
  159.       var I,F : integer;
  160.           X,Y : ITEM;
  161.       begin
  162.         case N of
  163.    1,2: begin (* READ *)
  164.           if NOT ifLAG then begin
  165.             ERROR(59);
  166.             IFLAG := TRUE;
  167.           end;
  168.           if SY = LPARENT then begin
  169.             repeat
  170.               INSYMBOL;
  171.               if DFLAG AND ( SY <> IDENT ) then begin
  172.                 I := pos( ' ', ID );
  173.                 if copy( ID, 1, i-1 ) = copy( DFILE, 11-i, i-1 )
  174.                   then INSYMBOL else ERROR(2);
  175.               end;
  176.               if SY <> IDENT then ERROR(2) else begin
  177.                 I := LOC(ID);
  178.                 INSYMBOL;
  179.                 if I <> 0 then if TAB[I].OBJ <> VARIABLE
  180.                   then ERROR(37) else begin
  181.                     X.TYP := TAB[I].TYP;
  182.                     X.REF := TAB[I].REF;
  183.                     if TAB[I].NORMAL then F := 0 else F := 1;
  184.                     EMIT2(F, TAB[I].LEV, TAB[I].ADR);
  185.                     if SY in [LBRACK,LPARENT,PERIOD] then
  186.                       SELECTOR(FSYS+[COMMA,RPARENT], X);
  187.                     if X.TYP in [INTS,REALS,CHARS,NOTYP] then
  188.                       EMIT1(27,ORD(X.TYP)) else ERROR(41)
  189.                 end;
  190.               end;
  191.               TEST([COMMA,RPARENT], FSYS, 6);
  192.             until SY <> COMMA;
  193.             if SY = RPARENT then INSYMBOL else ERROR(4)
  194.           end;
  195.           if N = 2 then EMIT(62)
  196.         end;
  197.  
  198.    3,4: begin { WRITE }
  199.           if SY = LPARENT then begin
  200.             repeat
  201.               INSYMBOL;
  202.               if SY = WORD then begin
  203.                 EMIT1(24,SLENG);
  204.                 EMIT1(28,INUM);
  205.                 INSYMBOL;
  206.               end else begin
  207.                 EXPRESSION(FSYS+[COMMA,COLON,RPARENT], X);
  208.                 if NOT (X.TYP in STANTYPS) then ERROR(41);
  209.                 if SY = COLON then begin
  210.                   INSYMBOL;
  211.                   EXPRESSION(FSYS+[COMMA,COLON,RPARENT], Y);
  212.                   if Y.TYP <> INTS then ERROR(43);
  213.                   if SY = COLON then begin
  214.                     if X.TYP <> REALS then ERROR(42);
  215.                     INSYMBOL;
  216.                     EXPRESSION(FSYS+[COMMA,RPARENT], Y);
  217.                     if Y.TYP <> INTS then ERROR(43);
  218.                     EMIT(37)
  219.                   end else EMIT1(30, ORD(X.TYP))
  220.                 end
  221.                 else EMIT1(29, ORD(X.TYP))
  222.               end
  223.             until SY <> COMMA;
  224.             if SY = RPARENT then INSYMBOL else ERROR(4)
  225.           end;
  226.           if N = 4 then EMIT(63)
  227.         end;
  228.     5,6:  { WAIT,SIGNAL }
  229.       if SY <> LPARENT then ERROR(9) else begin
  230.         INSYMBOL;
  231.         if SY<>IDENT then ERROR(0) else begin
  232.           I := LOC(ID);
  233.           INSYMBOL;
  234.           if I <> 0 then if TAB[I].OBJ <> VARIABLE then ERROR(37)
  235.             else begin
  236.               X.TYP:=TAB[I].TYP;
  237.               X.REF:=TAB[I].REF;
  238.               if TAB[I].NORMAL then F:=0 else F:=1;
  239.               EMIT2(F,TAB[I].LEV,TAB[I].ADR);
  240.               if SY in [LBRACK,LPARENT,PERIOD] then SELECTOR(FSYS+[RPARENT],X);
  241.               if X.TYP=INTS then EMIT(N+1) else ERROR(43)
  242.               end
  243.             end;
  244.             if SY=RPARENT then INSYMBOL else ERROR(4)
  245.           end;
  246.         end (* CASE *)
  247.       end; (* STANDPROC *)
  248.  
  249.     begin (*STATEMENT*)
  250.       if SY in STATBEGSYS+[IDENT] then
  251.           case SY of
  252.             IDENT:    begin
  253.                         I := LOC(ID);
  254.                         INSYMBOL;
  255.                         if I <> 0 then case TAB[I].OBJ of
  256.  
  257.                           KONSTANT,
  258.                           TYPE1    : ERROR(45);
  259.                           VARIABLE : ASSIGNMENT(TAB[I].LEV, TAB[I].ADR);
  260.                           PROZEDURE: if TAB[I].LEV <> 0 then CALL(FSYS, I)
  261.                                        else STANDPROC(TAB[I].ADR);
  262.                           FUNKTION : if TAB[I].REF = DISPLAY[LEVEL]
  263.                                        then ASSIGNMENT(TAB[I].LEV+1, 0)
  264.                                          else ERROR(45);
  265.                         end; (* case *)
  266.                       end;
  267.  
  268.             BEGINSY  :  if ID = 'COBEGIN   ' then begin
  269.                           EMIT(4);
  270.                           COMPOUNDSTMNT;
  271.                           EMIT(5)
  272.                         end else COMPOUNDSTMNT;
  273.  
  274.             IFSY     :     IFSTATEMENT;
  275.             CASESY   :   CASESTATEMENT;
  276.             WHILESY  :  WHILESTATEMENT;
  277.             REPEATSY : REPEATSTATEMENT;
  278.             FORSY    :    FORSTATEMENT;
  279.           end;
  280.         TEST(FSYS, [], 14)
  281.     end (*STATEMENT*) ;
  282.  
  283. begin (*BLOCK*)
  284.   DX := 5;
  285.   PRT := T;
  286.   if LEVEL > LMAX then FATAL(5);
  287.   TEST([LPARENT,COLON,SEMICOLON], FSYS, 14);
  288.   ENTERBLOCK;
  289.   DISPLAY[LEVEL] := B;
  290.   PRB := B;
  291.   TAB[PRT].TYP := NOTYP;
  292.   TAB[PRT].REF := PRB;
  293.   if ( SY = LPARENT ) AND ( LEVEL > 1 ) then PARAMETERLIST;
  294.   BTAB[PRB].LASTPAR := T;
  295.   BTAB[PRB].PSIZE := DX;
  296.   if ISFUN then
  297.     if SY = COLON then begin
  298.       INSYMBOL;   (*FUNCTION TYPE*)
  299.       if SY = IDENT then begin
  300.         X := LOC(ID);
  301.         INSYMBOL;
  302.         if X <> 0 then
  303.           if TAB[X].OBJ <> TYPE1 then ERROR(29) else
  304.             if TAB[X].TYP in STANTYPS then TAB[PRT].TYP := TAB[X].TYP
  305.               else ERROR(15)
  306.       end else SKIP([SEMICOLON]+FSYS, 2)
  307.     end else ERROR(5);
  308.   if SY = SEMICOLON then INSYMBOL else ERROR(14);
  309.   repeat
  310.     if SY = CONSTSY then CONSTDECLARATION;
  311.     if SY =  TYPESY then  TYPEDECLARATION;
  312.     if SY =   VARSY then    VARDECLARTION;
  313.     BTAB[PRB].VSIZE := DX;
  314.     while SY in [PROCSY,FUNCSY] do PROCDECLARATION;
  315.     TEST([BEGINSY], BLOCKBEGSYS+STATBEGSYS, 56)
  316.   until SY in STATBEGSYS;
  317.   TAB[PRT].ADR := LC;
  318.   INSYMBOL;
  319.   STATEMENT([SEMICOLON,ENDSY]+FSYS);
  320.   while SY in [SEMICOLON]+STATBEGSYS do begin
  321.     if SY = SEMICOLON then INSYMBOL else ERROR(14);
  322.     STATEMENT([SEMICOLON,ENDSY]+FSYS)
  323.   end;
  324.   if SY = ENDSY then INSYMBOL else ERROR(57);
  325.   TEST(FSYS+[PERIOD], [], 6)
  326. end; { block }
  327.